home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol076 / xmodem.old < prev    next >
Encoding:
Text File  |  1987-01-14  |  48.6 KB  |  1,637 lines
  1.  
  2. c    program xmodem50
  3. c               MODEM7-type program to send and
  4. c               receive files with checksums or CRC and automatic
  5. c               re-transmission of bad blocks.
  6. c               translated to VAX Fortran V3.0 from TMODEM.C
  7. c               and enhanced according to time-outs and CRC
  8. c               in XMODEM50.ASM
  9. c               J.James Belonis II
  10. c               Physics Hall FM-15
  11. c               University of Washington
  12. c               Seattle, WA 98195
  13. c        (206) 545-8695
  14. c
  15. c  TMODEM.C written by Richard Conn, Eliot Moss, and Lauren
  16. c   Weinstein
  17. c
  18. c  1/25/84 properly placed CALL PASSALL in main program so not miss parity bit
  19. c        in sendfn filename checksum
  20. c  1/ 8/84 corrected last known bugs
  21. c  1/ 2/84 Version 5.4 Added batch
  22. c 12/31/83 Version 5.3 Added wildcard filenames(but not yet batch) and
  23. c        streamlined option parsing and allowed CRC TEXT
  24. c        found and fixed blank trim miscalculation
  25. c        again (CONN apparently got old version)
  26. c        XMODEM.LOG and XMODEM.WRK put in SYS$SCRATCH directory
  27. c        (usually user's main) if can't open in current directory
  28. c 12/27/83 Version 5.2 Speeded up SEND by doing only one TTYOUT call per block.
  29. c           no longer hogs CPU at 9600 baud (only 15-20 percent of cpu time)
  30. c           included QIO.DCK so only one file XMODEM.FOR is needed.
  31. c  6/30/83 Modified, restructured, and VAX/VMS text file
  32. c       conversion added by Richard Conn
  33. c  1/17/83      touched up filename display and comments.
  34. c  1/14/83      including timeouts and CTRL-X cancellation
  35. c               and CRC capability
  36. c
  37. c  keeps a log file of error messages ( deletes it if no errors )
  38. c  sets terminal driver to eightbit, passall
  39. c  may need altypeahd if faster than 1200 baud works to 9600 baud at least.
  40. c  needs PHY_IO privilege for passall ? apparently not on UWPhys VAX
  41. c  nor on ACC VAX
  42. c  many debugging statements left in as comments
  43.  
  44. c  declare variables
  45.  
  46.     include  '($rmsdef)'    ! for LIB$FIND_FILE
  47.        INTEGER*2 CHAN,STATUS(4)
  48.        COMMON /QIO/ CHAN,STATUS
  49.  
  50.         character*128 line, filein, file, filec, filed, workf, options
  51.         integer seploc, worklen, context, istat, length, lengthin
  52.     logical openok, sendopt, recvopt, textopt
  53.     logical getfn, sendfn
  54.  
  55.     logical batchopt,firstbatch
  56.     common /batch/batchopt,firstbatch
  57.  
  58.         logical filedel
  59.         common /filest/filedel
  60.  
  61.         integer errorcount
  62.         common /err/errorcount
  63.  
  64.         integer high,low
  65.     byte highbyte,lowbyte
  66.         common /crcval/high,low
  67.     equivalence (high,highbyte)
  68.     equivalence (low,lowbyte)
  69.  
  70.         logical crc
  71.         byte checksumbyte
  72.         integer checksum
  73.         common /checks/checksum,crc
  74.         equivalence (checksum,checksumbyte)
  75.  
  76.         equivalence (ic,c)
  77.  
  78. c  define ascii characters
  79.         parameter NUL=0         !ignore at SOH time
  80.         parameter SOH=1         !start of header for sector
  81.         parameter EOT=4         !end of transfer
  82.         parameter ACK=6         !acknowlege sector
  83.     parameter BEL=7        !bell warning if stupid
  84.         parameter NAK=21        !not acknowlege sector
  85.         parameter CAN=24        !cancel transfer
  86.         parameter CRCCHAR='C'   !CRC indicating character
  87.  
  88. c  timeouts
  89.         parameter respnaklim=10 !seconds to allow for response to NAK
  90.         parameter naklim=10     !seconds to allow to receive first NAK
  91.         parameter eotlim=10     !seconds to wait for EOT acknowlege
  92.  
  93.         parameter errlim=10     !max errors on a sector
  94.  
  95. c  define an exit routine to get control on all exits to turn off
  96. c  passall and for debug cleanup
  97.             external giveup
  98.         call userex( giveup )
  99.  
  100.         print *,' XMODEM Version 5.4 on VAX VMS, BATCH capable'
  101. c  log file for debugging
  102. c  assign terminal channel for QIO calls to send raw bytes.
  103.         call sys$assign('TT',chan,,)
  104.  
  105. c  get command line
  106.         call lib$get_foreign(line,'$_Command: ',,)
  107. c  trim blanks
  108.         do i=80,1,-1
  109.                 length=i
  110.                 if(line(i:i).NE.' ') goto 25
  111.         enddo
  112. c  no command on line
  113.   25    continue
  114.  
  115. c  separate options from filename
  116. c    print *,' length=',length
  117.     seploc = index( line(1:length+1),' ' ) ! +1 so find end if one argument
  118. c    print *,' seploc=',seploc
  119.     options=line(1:seploc-1)
  120.     filein=line(seploc+1:length)
  121. c    print *,'options*',options(1:seploc-1),'*'
  122.     lengthin=length-seploc
  123.     if(lengthin.gt.0) then    ! make sure not index infinite length string
  124.         if(  index( filein(1:lengthin), ' ' ) .ne. 0  ) then
  125. c        print *,'filein*',filein(1:lengthin),'*'
  126. c        print *,'index( filein,'' '')',index(filein(1:lengthin),' ')
  127.         print *,' too many arguments'
  128.         goto 150
  129.         endif
  130.     endif
  131.      
  132.         filedel=.false.
  133. c  parse the options
  134.     batchopt=.false.
  135.     firstbatch=.false.
  136.     textopt=.false.
  137.     sendopt=.false.
  138.     recvopt=.false.
  139.     crc=.false.
  140.     i=0
  141.     if( index(options,'B').NE.0 ) then
  142.         batchopt=.true.
  143.         firstbatch=.true.
  144.         i=i+1
  145.     endif
  146.     if( index(options,'T').NE.0 ) then
  147.         textopt=.true.
  148.         i=i+1
  149.     endif
  150.     if( index(options,'S').NE.0 ) then
  151.         sendopt=.true.
  152.         i=i+1
  153.     endif
  154.     if( index(options,'R').NE.0 ) then
  155.         recvopt=.true.
  156.         i=i+1
  157.     endif
  158.     if( index(options,'C').NE.0 ) then
  159.         crc=.true.
  160.         i=i+1
  161.     endif
  162.  
  163. c  check options
  164.     if(i.ne.seploc-1) then
  165.         print *,char(BEL),' unsupported options ignored'
  166.         print *
  167.     endif
  168.     if(sendopt.and.recvopt) then    ! send and receive simultaneously
  169.         print *,' incompatible options SEND and RECEIVE'
  170.         call exit
  171.     endif
  172.     if(  .not.(recvopt.and.batchopt) .and. lengthin.le.0 ) then
  173. c  no options or no filename
  174.         print *,' insufficient arguments'
  175.         goto 150
  176.     endif
  177.     if( lengthin.gt.0 .and. (recvopt.and.batchopt) ) then
  178.         print *,' filename ignored on batch receive',char(BEL)
  179.     endif
  180.  
  181.  
  182.     context=0    ! initial FAB pointer for LIB$FILE_FIND
  183.         call passall(CHAN,.TRUE.)    ! turn on passall so typeahead
  184.                     ! not strip parity on unsolicited chars
  185. c  BATCH option loop comes here
  186. 100    continue    !GOTO at end comes here for next filename
  187.  
  188. c  open separate log file for each transferred file.
  189.     openok=.true.
  190.     workf='XMODEM.WRK'
  191.     worklen=10
  192.     open(8,file='XMODEM.LOG', iostat=istat,
  193.      1                         carriagecontrol='LIST',status='NEW')
  194.     if(istat.ne.0) then
  195.         if(firstbatch) then
  196.         print *,' Can''t open XMODEM.LOG in this directory,'
  197.         print *,' putting it in your main directory.',char(BEL)
  198.             endif
  199.             open(8,file='SYS$SCRATCH:XMODEM.LOG',
  200.      1                         carriagecontrol='LIST',status='NEW')
  201.         openok=.false.
  202.         workf='SYS$SCRATCH:XMODEM.WRK'
  203.         worklen=22      ! number of chars in file name
  204.     endif
  205.  
  206.     if(recvopt) then        ! wildcards done on other computer
  207.         if(.not.batchopt) then
  208.             file=filein
  209.             length=lengthin
  210.         endif
  211.     else    ! sending, need name(s)
  212.         istat=lib$find_file(filein(1:lengthin),file,context,,)
  213.         if(istat.eq.rms$_nmf) then    ! no more files
  214.             if(batchopt) then !await rcvr's request for filename
  215.                 call waitnlp(80) 
  216.                 call ttyout(ACK,1)    ! tell yes file
  217.             endif
  218.             call ttyout(EOT,1)    ! tell other computer no more
  219.                         ! it receives EOT as first
  220.                         ! char of expected filename
  221. c                print *,' All transfers complete.'
  222.                     write(8,*) ' All transfers complete.'
  223.             close(8,dispose='delete')    ! .LOG file
  224.             call exit
  225.         endif
  226.         if(.not.istat) then
  227.             if(firstbatch.or..not.batchopt) then
  228.                 print *,' LIB$FILE_FIND error'
  229.             endif
  230.             write(8,*) ' LIB$FILE_FIND error'
  231.             call cancel
  232.         endif
  233. c  trim blanks
  234.             do i=128,1,-1
  235.                     length=i
  236.                     if(file(i:i).NE.' ') goto 125
  237.             enddo
  238. c        print *,' couldn''t happen, filename blank'
  239.         write(8,*) ' couldn''t happen, filename blank'
  240.  125        continue
  241.  
  242.     endif
  243.  
  244.     if( sendopt ) then
  245. c  send
  246.         if(batchopt) then
  247. c                                       make a reasonable filename
  248.             call cleansfn( file(1:length),filec,leng)
  249.             if(firstbatch) then
  250.               print *,' sending BATCH mode, please run receiver'
  251.             endif
  252.             call sendfn( filec(1:leng) )
  253.         endif
  254.         if(textopt) then
  255.             if(.not.batchopt) then    ! not batch
  256.                         print *,' Sending Text File: ',file(1:length)
  257.                 print *,' Do not run your receiver yet.'
  258.             endif
  259.                     call vtoc( file(1:length), workf(1:worklen) )
  260. c            print *,' file converted'
  261. c            write(8,*) ' file converted'
  262.                     filedel=.true.  !delete working file when done
  263.                     call sendfile( workf(1:worklen) )
  264.         else    ! not text
  265.             if(.not.batchopt) then
  266.                         print *,' Sending File: ',file(1:length)
  267.             endif
  268.                     call sendfile( file(1:length) )
  269.         endif        
  270.  
  271.     elseif(recvopt) then
  272. c  receive
  273.         if(batchopt) then
  274.             if(firstbatch) then
  275.                print *, ' Receiving BATCH please run sender'
  276.             endif
  277.             if(.not.getfn(filed,leng)) then
  278.                 call ttyout(EOT,1)
  279. c                print *,' All transfers complete.'
  280.                 write(8,*) ' All transfers complete.'
  281.                 close(8,dispose='delete')    ! log file
  282.                 call exit
  283.             endif
  284.             call cleangfn(filed(1:leng),file,length)
  285.         endif
  286.         if(textopt) then
  287.             if(.not.batchopt) then
  288.                         print *,' Receiving Text File: ',file(1:length)
  289.             endif
  290.                     call recvfile( workf(1:worklen) )
  291.                     filedel=.true.  !delete working file when done
  292.                     call ctov( workf(1:worklen), file(1:length) )
  293.         else    ! not text
  294.             if(.not.batchopt) then
  295.                         print *,' Receiving File: ',file(1:length)
  296.             endif
  297.                     call recvfile( file(1:length) )
  298.         endif
  299.     else
  300. c  else bad command
  301. 150            print *,' Invalid XMODEM Command --'
  302.             print *,' Usage: XMODEM  <SRCTB>  <file> '
  303.             print *,'   S = Send, R = Receive, C = Use CRCs, B = Batch'
  304.             print *,'   T = Convert text files to/from CP/M or VAX/VMS'
  305.     endif
  306.  
  307.     if( batchopt ) then
  308.         firstbatch=.false.    ! don't print informational messages
  309.                     ! from now on
  310.         goto 100        ! get next filename
  311.     endif
  312.  
  313. 200     call exit    ! should probably have a unified exit here ??
  314.  
  315.         end
  316. c------------------------------------------------------
  317.     subroutine cleansfn(file,fileclean,length)
  318.     character*(*) file, fileclean
  319.     integer length
  320. c  clean send file name
  321. c  remove too-specific parts of filename (directory and version)
  322. c  and make understandable by CP/M  11 char no dot, last 3 for type
  323.  
  324.     fileclean=' '
  325.     start=index( file,']' )+1
  326.     end=index( file, ';' )-1
  327.     dot = start-1 + index( file(start:end),'.' )    ! VMS guarantees a dot
  328.     if(start.ne.dot) fileclean(1:)=file(start:dot-1)
  329.     if(dot.ne.end) fileclean(9:)=file(dot+1:end)
  330.     ! note: may overwrite last char of vax 9 char filename before dot
  331.     length=11
  332.     return
  333.  
  334.     end
  335.  
  336. c-------------------------------------
  337.     subroutine sendfn(file)
  338.     character*(*) file
  339. c  sends name for batch checksummed send                
  340.  
  341.     byte c
  342.     integer ic
  343.     equivalence (ic,c)
  344.  
  345.         logical ttyinlim
  346.  
  347.         logical crc
  348.         byte checksumbyte
  349.         integer checksum
  350.         common /checks/checksum,crc
  351.         equivalence (checksum,checksumbyte)
  352.  
  353.     parameter BDNMCH=117    ! badname character 'u'
  354.     parameter OKNMCH=6    ! good name character
  355.     parameter ACK=6        ! acknowlege character
  356.     parameter EOF=26    ! filename terminator
  357.  
  358. 100    continue
  359. c    print *,' Awaiting name NAK'
  360. c    write(8,*) ' Awaiting name NAK'
  361.     call waitnlp(80)    ! await NAK
  362.     call ttyout(ACK,1)    ! tell receiver a filename follows
  363.  
  364.     checksum=0
  365. c    print *,file
  366. c    write(8,*) file
  367.     do i=1,len(file)
  368.         c=ichar( file(i:i) )
  369. c        print *, ' filename character=',c
  370. c        write(8,*) ' filename character=',c
  371.         checksum=checksum+c
  372. c        print *,' checksum=',checksum
  373. c        write(8,*) ' checksum=',checksum
  374.         call ttyout(c,1)
  375. 200        if( .not.ttyinlim(c,1,1) ) then
  376. c            print *,' timeout during name'
  377.             write(8,*) ' timeout during name'
  378.             goto 300
  379.         endif
  380. c        print *,' ACK char received decimal=',c
  381. c        write(8,*) ' ACK char received decimal=',c
  382.         if(c.ne.ACK) goto 200    ! let it time out if bad   eat chars ?
  383.     enddo
  384. c    print *,' EOF end of filename'
  385. c    write(8,*) ' EOF end of filename'
  386.     checksum=checksum+EOF
  387.     call ttyout(EOF,1)
  388.     if( .not.ttyinlim(c,1,1) ) then    ! checksum from receiver (MODEM765.ASM
  389.                     ! did not check for timeout)
  390. c        print *,' timeout awaiting checksum in sendfn'
  391.         write(8,*) ' timeout awaiting checksum in sendfn'
  392.         goto 300
  393.     endif
  394.     if( checksumbyte.ne.c ) then
  395. c  bad filename transmission
  396. c        print *,' checksum,byte,c=',checksum,checksumbyte,c
  397.         write(8,*) ' checksum,byte,c='
  398.         write(8,'(3z10)') checksum,checksumbyte,c
  399. 300        continue
  400. c        print *,' BDNMCH = u'
  401. c        write(8,*) ' BDNMCH = u'
  402.         call ttyout(BDNMCH,1)    ! lower case u (but receiver
  403.                     ! only cares that it was not ACK)
  404. c        print *,' receiver better NAK now to start again'
  405.         goto 100
  406.     endif
  407. c    print *,' filename sent ok'
  408. c    write(8,*) ' filename sent ok'
  409.     call ttyout(OKNMCH,1)    ! ACK
  410.     return
  411.     end
  412.  
  413. c---------------------------------------------------------
  414.     subroutine waitnlp(sec)
  415.     integer sec
  416. c  Await NAK, abort if not here in n seconds
  417.  
  418.     integer count
  419.         logical ttyinlim
  420.     byte c
  421.     parameter NAK=21
  422.     parameter CAN=24
  423.  
  424.     count=0
  425. 100    if( .not.ttyinlim(c,1,1) ) then    ! timeout
  426.         count=count+1
  427.         if(count.ge.sec) call cancel    ! passed limit
  428.         goto 100
  429.     endif
  430.     if( c.eq.CAN ) call cancel
  431.     if( c.ne.NAK ) goto 100
  432.     return
  433.  
  434.     end
  435.  
  436. c---------------------------------------
  437.     logical function getfn(file,length)
  438.     character*(*) file
  439.     integer length
  440. c  get the characters of the batch mode filename  (return false if no more)
  441. c  note: must be declared in callers too.
  442.  
  443.         logical ttyinlim, hsnak
  444.  
  445.     integer ic    ! so char(ic) works
  446.     byte c
  447.  
  448.         logical crc
  449.         byte checksumbyte
  450.         integer checksum
  451.         common /checks/checksum,crc
  452.         equivalence (checksum,checksumbyte)
  453.  
  454.     parameter EOT=4        ! end of batch transfer
  455.     parameter ACK=6        ! acknowledge character
  456.     parameter OKNMCH=6    ! OK name character   ACK
  457.     parameter EOF=26    ! end of filename
  458.  
  459.     getfn=.true.
  460. 100    if( .not.hsnak() ) goto 100    ! may hang 'til CTRL-X
  461.  
  462.     checksum=0
  463.     length=0
  464.     file=' '    ! blank filename
  465. 200    if( .not.ttyinlim(ic,1,1) ) then
  466. c        print *,' Time out receiving filename'
  467.         write(8,*) ' Time out receiving filename'
  468.         goto 100    ! give up and restart handshaking
  469.     endif
  470.     length=length+1
  471.     file(length:length)=char(ic)
  472. c    print *,' filename char=',ic
  473. c    write(8,*) ' filename char=',ic
  474. c    print *,' filename=',file(1:length)
  475. c    write(8,*) ' filename=',file(1:length)
  476.     checksum=checksum+ic
  477.  
  478.     if(ic.eq.EOT) then    ! no more filenames
  479. c        write(8,*) ' getfn got EOT'
  480.         getfn=.false.
  481.         return
  482.     endif
  483.  
  484.     if(ic.eq.EOF) then
  485.         length=length-1
  486. c        print *,' getfn got EOF'
  487. c        write(8,*) ' getfn got EOF'
  488. c        print *,file(1:length)
  489.         write(8,*) file(1:length)
  490.         call ttyout(checksumbyte,1)    ! send calculated checksum
  491.         if(.not.ttyinlim(c,1,1) ) then    ! get verification of checksum
  492.                         ! MODEM765 had no timeout check
  493.             print *,' timeout awaiting checksum ok'
  494.             write(8,*) ' timeout awaiting checksum ok'
  495.             goto 100    ! restart handshake
  496.         endif
  497.         if(c.eq.OKNMCH) return
  498.  
  499. c        print *,' Checksum error, verification c=',c
  500.         write(8,*) ' Checksum error, verification c=',c
  501.         goto 100    ! restart handshaking
  502.     endif
  503.  
  504.     call ttyout(ACK,1)
  505.  
  506.     if(i.gt.128) then    ! note: match dimension of "file" in main
  507. c        print *,' Too many characters in filename'
  508.         write(8,*) ' Too many characters in filename'
  509.         goto 100    ! start again at NAK
  510.     endif
  511.     goto 200    ! get next char
  512.  
  513.     end
  514.  
  515. c--------------------------------------
  516.     logical function hsnak()
  517. c  true if get ACK in response to NAK, c returns null if timeout  ???
  518. c  note: must be declared in callers too.
  519.  
  520.     byte c
  521.     logical ttyinlim
  522.     parameter ACK=6
  523.     parameter CAN=24
  524.     parameter NAK=21
  525.  
  526.     call ttyout(NAK,1)
  527. c  checking for CTRL-X is the only way to get out of the loop that
  528. c  calls hsnak
  529.     if( .not.ttyinlim(c,1,2) ) then    ! timeout don't care what c is
  530.         write(8,*) ' hsnak timeout'
  531.         hsnak=.false.
  532.     elseif(c.eq.ACK) then
  533.         hsnak=.true.
  534. c        print *,' hsnak got ACK'
  535. c        write(8,*) ' hsnak got ACK'
  536.     elseif(c.eq.CAN) then
  537.         call cancel
  538. c       else    ! bad character, ignore
  539.     endif
  540.     return
  541.  
  542.     end
  543. c------------------------------------------------------
  544.     subroutine cleangfn(file,fileclean,length)
  545.     character*(*) file, fileclean
  546.     integer length
  547. c  clean get file name
  548. c  and make understandable by VAX 13 char with dot, last 3 for type
  549. c  should also replace non-alphanumeric
  550.  
  551.     leng=index(file//' ',' ')-1    ! add blank in case none in filename
  552. c    print *,' leng=',leng
  553.     leng=min(leng,8)    ! in case filename and type run together
  554. c    print *,' leng=',leng
  555.     fileclean(1:)=file(1:leng)//'.'//file(9:)
  556.     length=index(fileclean,' ')-1
  557. c    print *,' length=',length
  558. c    write(8,*) ' cleaned filename VAX form*',fileclean(1:length),'*'
  559.     return
  560.     end
  561. c----------------------------------------------------------------
  562. c  send file
  563.         subroutine sendfile(file)
  564.  
  565. c  declare variables
  566.  
  567.        INTEGER*2 CHAN,STATUS(4)
  568.        COMMON /QIO/ CHAN,STATUS
  569.  
  570.         character*(*) file
  571.  
  572.         byte sectorread(128), sector(130), send(133), c
  573.     equivalence (send(4), sector(1), sectorread(1) )
  574.  
  575.         integer nakwait, stat, ic
  576.         logical ttyinlim
  577.         logical charintime, acked
  578.  
  579.     logical batchopt, firstbatch
  580.     common /batch/batchopt,firstbatch
  581.  
  582.         logical filedel
  583.         common /filest/filedel
  584.  
  585.     integer blocknumber
  586.     byte blockbyte
  587.     equivalence (blocknumber,blockbyte)
  588.  
  589.     integer notblocknumber
  590.     byte notblockbyte
  591.     equivalence (notblocknumber,notblockbyte)
  592.  
  593.         integer errorcount
  594.         common /err/errorcount
  595.  
  596.         integer high,low
  597.     byte highbyte,lowbyte
  598.         common /crcval/high,low
  599.     equivalence (high,highbyte)
  600.     equivalence (low,lowbyte)
  601.  
  602.         logical crc
  603.     byte checksumbyte
  604.         integer checksum
  605.         common /checks/checksum,crc
  606.         equivalence (checksum,checksumbyte)
  607.  
  608.         equivalence (ic,c)
  609.  
  610. c  define ASCII characters
  611.         parameter NUL=0
  612.         parameter SOH=1
  613.         parameter EOT=4
  614.         parameter ACK=6
  615.         parameter NAK=21
  616.         parameter CAN=24
  617.         parameter CRCCHAR='C'
  618. c  timeouts
  619.         parameter respnaklim=10
  620.         parameter naklim=10
  621.         parameter eotlim=10
  622.         parameter errlim=10
  623.  
  624.         open(9,name=file,iostat=stat,status='OLD')
  625. c     1         carriagecontrol='NONE',recordtype='FIXED',recl=128)
  626.  
  627.         if(stat) then
  628.         if(.not.batchopt) then
  629.                     print *,'Can''t open ',file,' for send.'
  630.         endif
  631.                 write(8,*) 'Can''t open ',file,' for send.'
  632.                 call cancel
  633.         endif
  634.     if( .not.batchopt ) then
  635.             print *,file,' Open -- Please Run Your Receiver --'
  636.             print *
  637.     endif
  638.         errorcount=0
  639.         blocknumber=1
  640.         nakwait=0
  641.  
  642. c  await first NAK (or 'C') indicating receiver is ready
  643.   200   charintime=ttyinlim(c,1,naklim)         ! return NUL if timeout
  644. c        print *,' first NAK character=',c
  645. c        write(8,*) ' character=',c
  646.         if( .NOT.charintime ) then
  647.                 nakwait=nakwait+1
  648. c  give the turkey 80 seconds to figure out how to receive a file
  649.                 if(nakwait.ge.80/naklim) call cancel
  650.                 goto 200
  651.         elseif(c.EQ.NAK) then
  652.                 crc=.false.
  653. c        print *,' CHECKSUM mode'
  654.         write(8,*) ' CHECKSUM mode'
  655.         elseif(c.EQ.CRCCHAR) then
  656.                 crc=.true.
  657. c        print *,' CRC mode'
  658.         write(8,*) ' CRC mode'
  659.         elseif(c.EQ.CAN) then
  660.                 call cancel
  661.         else
  662. c  unrecognized character
  663.         write(8,*) 'unrecognized first NAK=',c
  664.                 nakwait=nakwait+1
  665.                 if(nakwait.ge.80/naklim) call cancel
  666.                 goto 200
  667.         endif
  668.  
  669.   300   continue
  670. c  send new sector
  671. c  use equivalence so not need to do inefficient implicit do loop in read
  672.         read(9,1000,end=500) sectorread
  673.  1000   format(128a)
  674.         errorcount=0
  675. c        print *,' sector as read',sector
  676. c        write(8,*) ' sector as read',sector
  677.   400   continue
  678. c  send sector
  679. c        print *,' SOH '
  680. c    write(8,*) ' SOH'
  681.         send(1)=SOH
  682. c  note: equivalence used for fast integer to byte conversion
  683. c        without byte overflow problems
  684.         send(2)=blockbyte
  685.     notblocknumber=not(blocknumber)
  686.         send(3)=notblockbyte
  687. c        print *,' blocknumber=',blocknumber
  688. c        write(8,*) ' blocknumber=',blocknumber
  689.  
  690. c  sector already in sending buffer    done by equivalence
  691.  
  692.         checksum=0
  693.         call clrcrc
  694. c  calc checksum or crc
  695.         if(crc) then
  696. c        write(8,*) ' CRC mode'
  697. c  put all bytes + two finishing zero bytes through updcrc
  698.                 sector(129)=0
  699.                 sector(130)=0
  700.                 call updcrc( sector,130 )
  701.                 send(132)=highbyte
  702.                 send(133)=lowbyte
  703. c        write(8,*) 'highbyte,lowbyte'
  704. c        write(8,'(2z10)') highbyte,lowbyte
  705. c  actually send
  706.         call ttyout(send,133)
  707.         else
  708. c        write(8,*) 'CHECKSUM mode'
  709.                 do i=1,128
  710.                         checksum=checksum+sector(i)
  711.                 enddo
  712. c  this sends low order byte of checksum
  713.                 send(132)=checksumbyte
  714. c                print *,' checksumbyte ',checksumbyte
  715. c                write(8,*) ' checksumbyte ',checksumbyte
  716.         call ttyout(send,132)
  717.         endif
  718.  
  719. c  sector sent, see if receiver acknowleges
  720. c  getack attempts to get ACK
  721. c  if not, repeat sector
  722. c        print *, ' should wait for ACK 10 seconds'
  723. c        write(8,*) ' should wait for ACK 10 seconds'
  724.  
  725.         call getack(acked)
  726. c        print *, ' getack returned=',acked
  727. c        write(8,*) ' getack returned=',acked
  728.         if(.NOT.acked) goto 400
  729.  
  730. c  ACK received, send next sector
  731.         blocknumber=blocknumber+1
  732.         goto 300
  733.  
  734. c  end of file during read.  finish up sending.
  735.   500   continue
  736.         call ttyout(EOT,1)
  737. c  getack attempts to get ACK up to errlim times
  738.         call getack(acked)
  739.         if( .NOT.acked ) goto 500
  740.  
  741. c        print *,' This file Sending complete.'
  742.         write(8,*) ' This file Sending complete.'
  743.         if (filedel) then
  744.                 close(9,dispose='DELETE')
  745.         else
  746.                 close(9)
  747.         endif
  748.         close(8,dispose='DELETE')    ! the .LOG file
  749.         return
  750.         end
  751.  
  752. c----------------------------------------------------------------
  753. c  receive file
  754.         subroutine recvfile(file)
  755.  
  756. c  declare variables
  757.  
  758.        INTEGER*2 CHAN,STATUS(4)
  759.        COMMON /QIO/ CHAN,STATUS
  760.  
  761.         character*(*) file
  762.         byte c, notc, ck
  763.         integer blocknumber, inotc, notnotc, secbytes, stat
  764.         integer testblock, testprev, ic
  765.         logical ttyinlim
  766.         logical charintime, firstsoh
  767.  
  768.     byte sector(130),sectorwrite(128)
  769.     equivalence (sector,sectorwrite)
  770.  
  771.     logical batchopt,firstbatch
  772.     common /batch/batchopt,firstbatch
  773.  
  774.         integer errorcount
  775.         common /err/errorcount
  776.  
  777.         integer high,low
  778.     byte highbyte,lowbyte
  779.         common /crcval/high,low
  780.     equivalence (high,highbyte)
  781.     equivalence (low,lowbyte)
  782.  
  783.         logical crc
  784.         byte checksumbyte
  785.         integer checksum
  786.         common /checks/checksum,crc
  787.         equivalence (checksum,checksumbyte)
  788.  
  789.         equivalence (ic,c)
  790.  
  791. c  define ASCII characters
  792.         parameter NUL=0
  793.         parameter SOH=1
  794.         parameter EOT=4
  795.         parameter ACK=6
  796.         parameter NAK=21
  797.         parameter CAN=24
  798.         parameter CRCCHAR='C'
  799. c  timeouts
  800.         parameter respnaklim=10
  801.         parameter naklim=10
  802.         parameter eotlim=10
  803.         parameter errlim=10
  804.  
  805.         open(7,name=file,recl=128,status='NEW',iostat=stat,
  806.      1          carriagecontrol='NONE',recordtype='FIXED')
  807.         if(stat) then
  808.         if(batchopt) then
  809.  
  810. c                    print *,' Can''t open ',file,' for recieve.'    
  811.                     write(8,*) ' Can''t open ',file,' for recieve.'    
  812.         else
  813.                     print *,' Can''t open ',file,' for recieve.'    
  814.                     write(8,*) ' Can''t open ',file,' for recieve.'    
  815.         endif
  816.         call cancel
  817.         endif
  818.  
  819.     if(.not.batchopt) then
  820.             print *,' Please Send Your File --'
  821.             print *
  822.     endif
  823.  
  824.         secbytes=129
  825.         if(crc) then
  826.                 secbytes=130
  827.         endif
  828.  
  829.         firstsoh=.false.
  830.         errorcount=0
  831.         blocknumber=1
  832.  
  833. c  start the sender by letting ttyinlim time-out in getack routine
  834. c  so it sends a NAK or C
  835.         goto 999
  836.  
  837.   800   continue
  838. c        write(8,*) ' ready for SOH'
  839. c  must allow enough time for other's disk read (xmodem50.asm allows 10sec)
  840.         charintime=ttyinlim(c,1,respnaklim)
  841. c  if no char for a while, try NAK or C again
  842.         if( .NOT.charintime ) then
  843. c                print*,' no response to NAK or C, trying again'
  844.                 write(8,*) ' no response to NAK or C, trying again'
  845.                 goto 999
  846.         endif
  847. c  else received a char so see what it is
  848.         if(c.eq.NUL) goto 800   ! ignore nulls here for compatablity with old
  849.                                 ! versions of modem7
  850.         if(c.EQ.CAN) then
  851. c                print *,' Canceled.  Aborting.'
  852.                 write(8,*) ' Canceled.  Aborting.'
  853.                 call exit
  854.         endif
  855.  
  856. c        print *,' EOT or SOH character=',c
  857. c        write(8,*) ' EOT or SOH character=',c
  858.         if(c.NE.EOT) then
  859.                 IF(c.NE.SOH) then
  860. c                        print *,' Not SOH, was decimal ',c
  861.                         write(8,*) ' Not SOH, was decimal ',c
  862.                         goto 999
  863.                 endif
  864.                 firstsoh=.true.
  865.  
  866. c  character was SOH to indicate start of header
  867. c  get block number and complement
  868.                 call ttyin(c,1)
  869. c                print *,' block=',c
  870. c                write(8,*) ' block=',c
  871.  
  872.                 call ttyin(notc,1)
  873. c                print *,' block complement=',notc
  874. c                write(8,*) ' block complement=',notc
  875.                 inotc=notc      ! make integer for "not" function
  876.                 notnotc=iand( not(inotc),255 )  ! mask back to byte
  877.  
  878. c  c is low order byte of ic via equivalence statement
  879.                 if(ic.NE.notnotc) then
  880. c                        print *,' block check bad.'
  881.                         write(8,*) ' block check bad.'
  882.                         goto 999
  883.                 endif
  884. c  block number valid but not yet checked against expected
  885.  
  886. c  clear checksum and CRC
  887.                 checksum=0
  888.                 call clrcrc
  889.  
  890. c  receive the sector and checksum bytes in one call (for speed).
  891. c  secbytes is 129 for checksum, 130 for CRC
  892.                 call ttyin(sector,secbytes)
  893.  
  894.                 if(crc) then
  895. c  put data AND CRC bytes through updcrc
  896.                         call updcrc(sector,secbytes)
  897. c  if result non-zero, BAD.
  898.                         if(highbyte.NE.0 .OR.
  899.      1                     lowbyte.NE.0     ) then
  900. c                                print *,' CRC, high,low='
  901.                                 write(8,*) ' CRC, high,low='
  902. c                                print 3000, highbyte,lowbyte
  903.                                 write(8,3000) highbyte,lowbyte
  904.  3000                           format(2z10)
  905.                                 goto 999
  906.                         endif
  907.                 else
  908. c  don't add received checksum byte to checksum
  909.                         do i=1,secbytes-1
  910.                                 checksum=checksum+sector(i)
  911.                         enddo
  912.                         ck=sector(129)
  913. c                        print 2100, ck
  914. c                        write(8,2100) ck
  915.  
  916. c                        print 2100, checksum
  917. c                        write(8,2100) checksum
  918. c                        print 2100, checksumbyte
  919. c                        write(8,2100) checksumbyte
  920. c 2100                   format(' checksum=',z10)
  921.                         if( checksumbyte.NE.ck ) then
  922.                                 write(8,*) ' bad checksum'
  923.                                 goto 999
  924.                         endif
  925.                 endif
  926.  
  927. c  received OK so we can believe the block number, see which block it was
  928. c  mask it to be one byte
  929.                 testblock=iand(blocknumber,255)
  930.                 testprev=iand( blocknumber-1 ,255)
  931.                 if( ic.EQ.testprev) then
  932. c                        print *, ' prev. block again, out of synch'
  933.                         write(8,*) ' prev. block again, out of synch'
  934. c  already have this block so don't write it, but ACK anyway to resynchronize
  935.                         goto 985
  936.                 elseif( ic.NE.testblock ) then
  937. c                        print *, ' block number bad.'
  938.                         write(8,*) ' block number bad.'
  939.                         goto 999
  940.                 endif
  941. c  else was expected block
  942.  
  943. c  write before acknowlege so not have to listen while write.
  944. c  equivalence so not need inefficient implicit do loop
  945.                 write(7,2000,err=900) sectorwrite
  946.  2000           format(128a)
  947.                 goto 975
  948.  
  949.   900           write(8,*) ' Can''t write sector. Aborting.'
  950. c                print *, ' Can''t write sector. Aborting.'
  951.                 call cancel
  952.  
  953.   975           continue
  954. c  recieved sector ok, wrote it ok, so acknowlege it to request next.
  955.                 blocknumber=blocknumber+1
  956. c  comes here if re-received the previous sector
  957.   985           continue
  958.                 errorcount=0
  959. c                print *, ' ACKing, sector was ok.'
  960. c                write(8,*) ' ACKing, sector was ok.'
  961.                 call ttyout(ACK,1)
  962.                 goto 800
  963.  
  964. c  else error so eat garbage in case out of synch and try again
  965.   999           continue
  966.                 call eat
  967. c                print *, ' receive error NAK, block=',blocknumber
  968.                 write(8,*) ' receive error NAK, block=',blocknumber
  969.                 if(crc.AND..NOT.firstsoh) then
  970. c  keep sending 'C'  'til receive first SOH
  971.                         call ttyout(CRCCHAR,1)
  972.                 else
  973.                         call ttyout(NAK,1)
  974.                 endif
  975.                 errorcount=errorcount+1
  976.   998           if(errorcount.GE.errlim) then
  977. c                        print *,' Unable to receive block. Aborting.'
  978.                         write(8,*) ' Not receive block. Aborting.'
  979. c  delete incompletely received file
  980.                         close(7,dispose='DELETE')
  981.                         call cancel
  982.                 endif
  983. c  retry
  984.                 goto 800
  985.         endif
  986.  
  987. c  EOT received instead of SOH so file done.
  988. c  should keep sending ACK 'til no more EOT's ?
  989.         close(9)
  990.         close(7)
  991.         call ttyout(ACK,1)
  992.         call ttyout(ACK,1)
  993.         call ttyout(ACK,1)
  994.  
  995.         write(8,*) ' Completed.'
  996. c       print *,   ' Completed.'
  997. c  transfer ok, so delete the error log file.
  998.         close(8,dispose='DELETE')
  999.         return
  1000.         end
  1001.  
  1002. c-------------------------------------------------------------
  1003.         subroutine ctov(input,output)
  1004. c  convert file of XMODEM 128 byte records with embedded <CR><LF>
  1005. c  marking end-of-line and CTRL-Z marking end-of-file
  1006. c  to carriage-control=LIST (normal VAX editable file)
  1007.  
  1008.         character*80 input,output
  1009.         character*300 line
  1010.         character*1 CR,LF,recchar
  1011.         logical eof, eol
  1012.     integer len
  1013.  
  1014.         logical filedel
  1015.         common /filest/filedel
  1016.  
  1017.     len=0
  1018.     eof=.false.
  1019.     eol=.false.
  1020.         CR=char(13)
  1021.         LF=char(10)
  1022.  
  1023.         open(9,file=input,status='OLD')
  1024. c  set maximum output record length to 300 (fortran default is 133)
  1025.         open(7,file=output,status='NEW',carriagecontrol='LIST',recl=300)
  1026.  
  1027. c  getchar (read new record if no input characters left)
  1028. c  if EOF on input, write line and exit
  1029. c  if CR then
  1030. c    if getchar LF then write line
  1031. c    else put back char and putchar CR into line (error if too long)
  1032. c    endif
  1033. c  else putchar (write error message if line too long)
  1034. c  endif
  1035. c  loop
  1036.  
  1037.   100   call getc(recchar,eof,eol)
  1038.         if(eof) goto 200
  1039.         if(recchar.eq.CR) then
  1040. c           PRINT *,' CR'
  1041.                 call getc(recchar,eof)
  1042.                 if(eof.or.recchar.ne.LF) then
  1043.                         call putback
  1044.  
  1045.                         len=len+1
  1046.                         if(len.ge.301) print *,' Out line too long.'
  1047. c               print *,' too long line=',line
  1048.                         line(len:len)=recchar
  1049.                 else
  1050. c  was LF
  1051. c               PRINT *,' LEN=',LEN
  1052. c               print *,' after LF, line=',line(1:len)
  1053.                         write(7,2000) line(1:len)
  1054.                         len=0
  1055.                 endif
  1056.         else
  1057. c  not CR, was "ordinary" character
  1058.                 len=len+1
  1059.                 if(len.ge.301) then
  1060.                         print *,' Out line too long.'
  1061. c                       PRINT *,' LINE=',LINE(1:len)
  1062.         else
  1063.                     line(len:len)=recchar
  1064.                 endif
  1065.         endif
  1066.  
  1067.         go to 100
  1068.  
  1069. c  flush last line and exit
  1070.   200   continue
  1071.         if(len.gt.0) then
  1072.                 write(7,2000) line(1:len)
  1073.  2000           format(a)
  1074.         len=0
  1075.         endif
  1076.         if (filedel) then
  1077.                 close(9,dispose='DELETE')
  1078.         else
  1079.                 close(9)
  1080.         endif
  1081.         close(7)
  1082.         return
  1083.         end
  1084. c------------------------------------------
  1085.         subroutine getc(c,eof)
  1086.         character*1 c
  1087.         logical eof
  1088. c  get character from a CP/M text file
  1089. c  point to next character in record (read record if necessary)
  1090.         character*1 CTRLZ
  1091.  
  1092.         integer point
  1093.         character*128 record
  1094.         common /reccom/point,record
  1095.         data point/0/
  1096.  
  1097.         logical firsttime
  1098.     common /getccom/firsttime
  1099.         data firsttime/.true./
  1100.  
  1101.         CTRLZ=char(26)
  1102.         point=point+1
  1103.         if( firsttime .or. (point.gt.128) ) then
  1104.                 firsttime=.false.
  1105.   100           read(9,1000,end=200) record
  1106.  1000           format(a)
  1107. c               PRINT *,RECORD
  1108.                 point=1
  1109.         endif
  1110. c  strip parity in case CP/M file had it
  1111.         c=char(iand(ichar(record(point:point)),127))
  1112.         if(c.eq.CTRLZ) goto 200        ! end of CP/M text file
  1113.     return
  1114.  
  1115. c  end of file
  1116.   200   eof=.true.
  1117.     firsttime=.true.    ! ready for next file
  1118.     point=0
  1119.         return
  1120.         end
  1121. c----------------------------------------------
  1122.     subroutine putback
  1123. c  point to previous input character so this character will be getchar result
  1124. c  even works if 1st char of record
  1125.     integer point
  1126.     character*128 record
  1127.     common /reccom/point,record
  1128.  
  1129.     point=point-1
  1130.     return
  1131.     end
  1132. c-------------------------------------------------------------
  1133.         subroutine vtoc(input,output)
  1134. c  convert VAX text file to
  1135. c  file of XMODEM 128 byte records with embedded <CR><LF>
  1136.  
  1137.         character*80 input,output
  1138.         character*1 CR,LF,c
  1139.         logical eof,eol
  1140.  
  1141.     eof=.false.
  1142.     eol=.false. 
  1143.         CR=char(13)
  1144.         LF=char(10)
  1145.  
  1146.         open(9,file=input,status='OLD',READONLY)
  1147.         open(7,file=output,status='NEW',carriagecontrol='LIST',
  1148.      1                               recl=128,recordtype='FIXED')
  1149.  
  1150. c  getchar (read new line if no input characters left)
  1151. c  putchar ( output record if full, close if EOF )
  1152. c  if EOL on input, putchar CR putchar LF (output record if full)
  1153. c  loop
  1154.  
  1155.   100   call getv(c,eof,eol)
  1156.         if(.not.eol) then
  1157.                 call putchar(c,eof)
  1158.                 if(eof) then
  1159.                         return
  1160.                 endif
  1161.         else
  1162. c  end of line
  1163.                 call putchar(CR,eof)
  1164.                 call putchar(LF,eof)
  1165.                 eol=.false.
  1166.                 if(eof) then
  1167.                         return
  1168.                 endif
  1169.         endif
  1170.         go to 100
  1171.  
  1172.         end
  1173. c------------------------------------------
  1174.         subroutine putchar(c,eof)
  1175.         character*1 c
  1176.         logical eof
  1177. c  put character into record (write record if necessary)
  1178. c  if eof, fills out rest of record with CTRL-Z's and exits
  1179.         character*1 CTRLZ
  1180.  
  1181.         integer point
  1182.         character*128 record
  1183.         common /reccom/point,record
  1184.         data point/0/
  1185.  
  1186.         if(eof) goto 200
  1187.         point=point+1
  1188. c  strip parity in case VAX file had it
  1189.         record(point:point)=char(iand(ichar(c),127))
  1190. c       print *,' record(point:point)=',record(point:point)
  1191. c       print *,' point=',point
  1192.    50   if(point.ge.128) then
  1193. c               print *,' record=',record
  1194.   100           write(7,1000) record
  1195.  1000           format(a)
  1196.                 point=0
  1197.         endif
  1198.         return
  1199.  
  1200. c  EOF fill record with 26's (CTRL-Z, CP/M end of file mark for ASCII)
  1201. c  output last record and exit
  1202.   200   continue
  1203. c       print *,' in putchar EOF section'
  1204.         CTRLZ=char(26)
  1205.         do i=point+1,128
  1206.                 record(i:i)=CTRLZ
  1207.         enddo
  1208. c       print *,' record=',record
  1209.         write(7,1000) record
  1210.         close(9)
  1211.         close(7)
  1212.     point=0        ! ready for next file
  1213.         return
  1214.         end
  1215. c-------------------------------------------
  1216.         subroutine getv(inchar,eof,eol)
  1217.         character*1 inchar
  1218.         logical eof,eol
  1219. c  get character from input line (read line if necessary)
  1220. c  returns character and eol=.true. if no more char on line
  1221. c  returns eof if end of file (no character)
  1222.         character*255 line
  1223.         integer len, pos
  1224.         logical firsttime
  1225.         common/lincom/pos,len,line
  1226.         data pos/0/
  1227.  
  1228.         if(pos.eq.0) then
  1229.                 read(9,1000,end=100)len,line(1:len)
  1230.  1000           format(q,a)
  1231. c               print *,' line=',line
  1232.         endif
  1233.         pos=pos+1
  1234.         if(pos.gt.len) then
  1235.                 eol=.true.
  1236.                 pos=0
  1237.                 return
  1238.         endif
  1239. c       print *,' pos=',pos,' line(1:pos)=',line(1:pos)
  1240. c       print *,' line(pos:pos)=',line(pos:pos)
  1241.         inchar=line(pos:pos)
  1242. c       print *,' pos,char',pos,inchar
  1243.         return
  1244. c  EOF
  1245.   100    continue
  1246.     eof=.true.
  1247.     return
  1248.     end
  1249. c-----------------------------------------------------------
  1250.     subroutine clrcrc
  1251. c  clears CRC
  1252.         integer high,low
  1253.     byte highbyte,lowbyte
  1254.         common /crcval/high,low
  1255.     equivalence (high,highbyte)
  1256.     equivalence (low,lowbyte)
  1257.  
  1258.     high=0
  1259.     low=0
  1260.     return
  1261.     end
  1262. c-----------------------------------------------------------
  1263.     subroutine updcrc(bbyte,n)
  1264.     byte bbyte(*)
  1265.     integer n
  1266. c  updates the Cyclic Redundancy Code
  1267. c  uses x^16 + x^12 + x^5 + 1 as recommended by CCITT
  1268. c    and as used by CRCSUBS version 1.20 for 8080 microprocessor
  1269. c    and incorporated into the MODEM7 protocol of the CP/M user's group
  1270. c
  1271. c  during sending:
  1272. c  call clrcrc
  1273. c  call updcrc   for each byte
  1274. c  call fincrc   to finish (or just put 2 extra zero bytes through updcrc)
  1275. c  result to send is low byte of high and low in that order.
  1276. c
  1277. c  during reception:
  1278. c  call clrcrc
  1279. c  call updcrc   all bytes PLUS the two received CRC bytes must be passed
  1280. c       to this routine
  1281. c       then zero in high and low means good checksum
  1282. c
  1283. c  see Computer Networks, Andrew S. Tanenbaum, Prentiss-Hall, 1981
  1284. c
  1285. c  must declare integer to allow shifting
  1286.     integer byte
  1287.     integer bit,bitl,bith
  1288.  
  1289.         integer high,low
  1290.     byte highbyte,lowbyte
  1291.         common /crcval/high,low
  1292.     equivalence (high,highbyte)
  1293.     equivalence (low,lowbyte)
  1294.  
  1295. c    write(8,*) ' inside updcrc'
  1296.     do i=1,n
  1297. c        write(8,*) 'high,low,byte'
  1298. c        write(8,1000) high,low,bbyte
  1299. c1000        format(3z10)
  1300.         byte=bbyte(i)
  1301.  
  1302.         do j=1,8
  1303. c  get high bits of bytes so we don't lose them when shift
  1304. c  positive is left shift
  1305.             bit =ishft( iand(128,byte), -7)
  1306.             bitl=ishft( iand(128,low),  -7)
  1307.             bith=ishft( iand(128,high), -7)
  1308. c            write(8,*) 'bit,bitl,bith'
  1309. c            write(8,1000) bit,bitl,bith
  1310. c  get ready for next iteration
  1311.             newbyte=ishft(byte,1)
  1312.             byte=newbyte        ! introduced dummy variable newbyte
  1313.                         ! to avoid "access violation"
  1314. c            write(8,*) ' byte ready for next iteration'
  1315. c            write(8,1000) byte
  1316. c  shift those bits in
  1317.             low =ishft(low ,1)+bit
  1318.             high=ishft(high,1)+bitl
  1319. c            write(8,*),' high,low after shifting bits in'
  1320. c            write(8,1000) high,low 
  1321.  
  1322.             if(bith.eq.1) then
  1323.                 high=ieor(16,high)
  1324.                 low=ieor(33,low)
  1325. c                write(8,*) ' high,low  after xor'
  1326. c                write(8,1000) high,low
  1327.             endif
  1328.         enddo
  1329.     enddo
  1330.         return
  1331.         end
  1332. c-----------------------------------------------------------
  1333. c    subroutine fincrc
  1334. c  finish CRC calculation for sending    result in high, low
  1335. c  merely runs updcrc with two  zero bytes
  1336. c       integer high,low
  1337. c       byte highbyte,lowbyte
  1338. c       common /crcval/high,low
  1339. c    equivalence (high,highbyte)
  1340. c    equivalence (low,lowbyte)
  1341. c
  1342. c    byte=0
  1343. c    call updcrc(byte)
  1344. c    call updcrc(byte)
  1345. c    return
  1346. c    end
  1347. c-----------------------------------------------------------
  1348.       SUBROUTINE TTYIN(LINE,N)
  1349.       BYTE LINE(*)
  1350.       INTEGER N
  1351. C              READ CHARACTERS FROM TERMINAL
  1352. C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE
  1353. C              MAY HAVE PROBLEM WITH TYPE-AHEAD
  1354. c  should convert to time-out properly with loops in main ?
  1355.  
  1356.        INTEGER*2 CHAN,STATUS(4)
  1357.        COMMON /QIO/ CHAN,STATUS
  1358.  
  1359.       INCLUDE '($SSDEF)'
  1360.       INTEGER I
  1361.       INTEGER SYS$QIOW
  1362.       INTEGER*4 terminators(2)
  1363.  
  1364. c      logical crc
  1365. c      integer checksum
  1366. c      common /checks/checksum,crc
  1367.  
  1368.       EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED 
  1369.       DATA terminators/0,0/
  1370. C 
  1371. c    write(8,*) ' inside ttyin, N=',N
  1372.       I = SYS$QIOW(,           !EVENT FLAG
  1373.      -              %VAL(CHAN),         !CHANNEL
  1374.      -              %VAL(%LOC(IO$_TTYREADALL).OR. 
  1375.      -                   %LOC(IO$M_NOECHO)),         !   .OR.%LOC(IO$M_TIMED)),
  1376.      -              STATUS,,, 
  1377.      -              LINE,       !BUFFER 
  1378.      -              %VAL(N),    !LENGTH
  1379.      -              ,        ! max time   beware other disk time
  1380.      -                !            and Quit or Retry time
  1381.      -              terminators,,)  !no terminators
  1382. c      if(crc) then
  1383. c         write(8,1000) (LINE(j),j=1,N)
  1384. c         write(8,*) ' status=',STATUS
  1385. c      else
  1386. c         write(8,2000) (line(j),j=1,N)
  1387. c         write(8,*) ' status=',status
  1388. c      endif
  1389. c 1000 format(' ttyin=',6(20z3/),10z3)
  1390. c 2000 format(' ttyin=',6(20z3/),9z3)
  1391.  
  1392.       IF (I) THEN
  1393. c        write(8,*) ' returning from ttyin'
  1394.          return
  1395.       endif
  1396. C 
  1397. C              ERROR
  1398.       write(8,*) ' ttyin error.'
  1399.       CALL SYS$EXIT( %VAL(I) )
  1400.       END 
  1401. c-----------------------------------------------------------
  1402.     subroutine eat
  1403. c  eats extra characters 'til 1 second pause   used to re-synch after error
  1404.     byte buffer(135)
  1405.     integer numchar
  1406.     logical i,ttyinlim
  1407. c
  1408.     parameter maxtime=1
  1409. c  in case mis-interpreted header, allow at least 1 block of garbage
  1410.     numchar=135
  1411.  
  1412.     i=ttyinlim(buffer,numchar,maxtime)
  1413. c    print *,' finished eating'
  1414. c    write(8,*) ' finished eating'
  1415.     return
  1416.     end
  1417. c-----------------------------------------------------------
  1418.       LOGICAL FUNCTION TTYINLIM(LINE,N,LIMIT)
  1419.       BYTE LINE(*)
  1420.       INTEGER N,LIMIT
  1421. C              READ CHARACTERS FROM TERMINAL 
  1422. C              WITH TIME LIMIT, RETURN FALSE IF NO CHARACTERS
  1423. C              RECEIVED FOR LIMIT SECONDS
  1424. C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE PROBLEM
  1425. C              MAY HAVE PROBLEM WITH TYPE-AHEAD 
  1426.  
  1427.        INTEGER*2 CHAN,STATUS(4)
  1428.        COMMON /QIO/ CHAN,STATUS
  1429.  
  1430.       INCLUDE '($SSDEF)'    ! defines error status returns
  1431.       INTEGER I
  1432.       INTEGER SYS$QIOW
  1433.       INTEGER*4 terminators(2)
  1434.       EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
  1435.       DATA TERMINATORS/0,0/
  1436. C 
  1437. c    write(8,*) ' inside ttyinlim'
  1438.       TTYINLIM=.TRUE.          ! DEFAULT no delay over LIMIT seconds
  1439.       I = SYS$QIOW(,           !EVENT FLAG
  1440.      -              %VAL(CHAN),         !CHANNEL
  1441.      -              %VAL(%LOC(IO$_TTYREADALL).OR. 
  1442.      -                   %LOC(IO$M_NOECHO).OR.%LOC(IO$M_TIMED)),
  1443.      -              STATUS,,,
  1444.      -              LINE,       !BUFFER
  1445.      -              %VAL(N),   !LENGTH
  1446.      -              %VAL(LIMIT),    !time limit in seconds
  1447.      -              terminators,,)  !no terminators 
  1448. c      print *,' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  1449. c      write(8,*) ' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  1450.       if(STATUS(1).EQ.SS$_TIMEOUT) THEN
  1451.          TTYINLIM=.FALSE.
  1452. c         print *, ' ttyinlim timeout'
  1453.          write(8,*) ' ttyinlim timeout'
  1454.          return
  1455.       ENDIF
  1456.  
  1457.       IF (I) THEN
  1458. c         print *, ' returning from ttyinlim'
  1459. c         write(8,*) ' returning from ttyinlim
  1460.          return
  1461.       endif
  1462. C 
  1463. C              ERROR
  1464.       write(8,*) ' ttyinlim error.'
  1465.       CALL SYS$EXIT( %VAL(I) )
  1466.       END 
  1467. c-----------------------------------------------------------
  1468.       SUBROUTINE TTYOUT(LINE,N) 
  1469.       BYTE LINE(*)
  1470.       INTEGER*2 N
  1471. C  output N characters without interpretation
  1472.  
  1473.        INTEGER*2 CHAN,STATUS(4)
  1474.        COMMON /QIO/ CHAN,STATUS
  1475.  
  1476.       INTEGER I 
  1477.       INTEGER SYS$QIOW
  1478.       EXTERNAL IO$M_NOFORMAT
  1479.       EXTERNAL IO$_WRITEVBLK
  1480. C 
  1481.       IF( N.LE.0 ) THEN
  1482.          WRITE(8,*) ' ttyout called with strange number of char ',N
  1483.          RETURN
  1484.       ENDIF
  1485. C 
  1486. c    print *, ' to be sent by ttyout ', (line(i),i=1,n)
  1487. c    write(8,*) ' to be sent by ttyout ', (line(i),i=1,n)
  1488.       I = SYS$QIOW(,
  1489.      -              %VAL(CHAN), 
  1490.      -              %VAL(%LOC(IO$_WRITEVBLK).OR.
  1491.      -                   %LOC(IO$M_NOFORMAT)),
  1492.      -              STATUS,,, 
  1493.      -              LINE, 
  1494.      -              %VAL(N),, 
  1495.      -              %VAL(0),, )         !NO CARRIAGE CONTROL 
  1496.       if(I) then
  1497.          return
  1498.       endif
  1499. C 
  1500. C              ERROR
  1501.       write(8,*) ' ttyout error.'
  1502.       CALL SYS$EXIT( %VAL(I) )
  1503.       END
  1504. c--------------------------------------------------
  1505.     subroutine giveup
  1506. c  this exit routine used especially in case exited via QIO problem
  1507.  
  1508.        INTEGER*2 CHAN,STATUS(4)
  1509.        COMMON /QIO/ CHAN,STATUS
  1510.  
  1511. c  note: if want log file message, must re-open since
  1512. c  system already closed all files before this exit handler got control
  1513. c    open(8,file='XMODEM.LOG',access='APPEND')
  1514. c    write(8,*) ' Exit handler.'
  1515.  
  1516. c  turn off passall
  1517.     call passall(CHAN,.FALSE.)
  1518.     return
  1519.     end
  1520. c-----------------------------------------------------
  1521.     SUBROUTINE PASSALL(CHAN,SWITCH)
  1522. C  sets PASSALL mode for terminal connected to chanel CHAN, ON if switch true
  1523.     IMPLICIT INTEGER (A-Z)
  1524.     INCLUDE '($TTDEF)'
  1525.     INCLUDE '($IODEF)'
  1526.     LOGICAL SWITCH
  1527.     COMMON/CHAR/CLASS,TYPE,WIDTH,CHARAC(3),LENGTH    !byte reversed LENGTH
  1528.     BYTE CLASS,TYPE,CHARAC,LENGTH
  1529.     INTEGER*2 WIDTH,SPEED
  1530.     EQUIVALENCE(CHARACTER,CHARAC)
  1531.  
  1532. c  sense current terminal driver mode
  1533.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),,,,
  1534.     1 CLASS,,,,,)
  1535.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SENSEMODE',ISTAT)
  1536.  
  1537.     IF(SWITCH) THEN
  1538. c  turn on 8 bit passall
  1539.         CHARACTER=CHARACTER.OR.TT$M_PASSALL.OR.
  1540.     1                TT$M_EIGHTBIT
  1541.     ELSE
  1542. c  turn off 8 bit passall
  1543.         CHARACTER=CHARACTER.AND..NOT.TT$M_PASSALL.AND.
  1544.     1                               .NOT.TT$M_EIGHTBIT
  1545.     ENDIF
  1546.     SPEED=0    !LEAVE SPEED UNCHANGED
  1547.     PAR=0    !LEAVE PARITY UNCHANGED
  1548.  
  1549. c  set terminal mode with desired passall
  1550.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE),,,,
  1551.     1               CLASS,,%VAL(SPEED),,%VAL(PAR),)
  1552.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SETMODE',ISTAT)
  1553.     RETURN
  1554.     END
  1555. c---------------------------------------------------
  1556.     SUBROUTINE ERROR(STRING,MSGID)
  1557. c        Types error message
  1558.     IMPLICIT INTEGER(A-Z)
  1559.     CHARACTER*(*) STRING
  1560.     CHARACTER*80 MESSAGE
  1561.  
  1562.     TYPE *,' *** ERROR: ',STRING
  1563.     write(8,*) ' *** ERROR: ',STRING
  1564.     CALL SYS$GETMSG(%VAL(MSGID),MSGLEN,MESSAGE,%VAL(15),)
  1565.     TYPE *,MESSAGE(1:MSGLEN),CRLF
  1566.     write(8,*) MESSAGE(1:MSGLEN),CRLF
  1567.     RETURN
  1568.     END
  1569. c-----------------------------------------------------------
  1570.     subroutine cancel
  1571.  
  1572.        INTEGER*2 CHAN,STATUS(4)
  1573.        COMMON /QIO/ CHAN,STATUS
  1574.  
  1575. c  called to cancel send (at least)
  1576.     logical ttyinlim
  1577.     byte c
  1578.     parameter CAN=24
  1579.     parameter SPACE=32
  1580.  
  1581. c  eat garbage
  1582.   100    if( ttyinlim(c,135,1) ) goto 100
  1583. c  cancel other end
  1584.     call ttyout(CAN,1)
  1585.  
  1586. c  eat garbage again in case it didn't understand ?
  1587.   200    if( ttyinlim(c,135,1) ) goto 200
  1588. c  clear the CAN from far end's input in case he has already cancelled and so
  1589. c    has not yet read it.
  1590. c      ???? why ? xmodem50.asm does it
  1591.  
  1592.     call ttyout(SPACE,1)
  1593.  
  1594. c    print*,' XMODEM program canceled'
  1595.     write(8,*)' XMODEM program canceled'
  1596.     call exit
  1597.     end
  1598. c------------------------------------------------------
  1599.     subroutine getack(acked)
  1600. c  returns .TRUE. if gets ACK 
  1601.     logical charintime, ttyinlim, acked
  1602.     byte sector(130),c
  1603.  
  1604.     integer errorcount
  1605.     common /err/errorcount
  1606.  
  1607.     parameter ACK=6
  1608.     parameter errlim=10    ! max number of errors
  1609.     parameter acklim=15    ! seconds to wait for ACK (xmodem.asm uses 10?)
  1610.                 ! but Stern's Northstar takes longer
  1611.                 ! to write 128 sectors
  1612.  
  1613. c    print*,' inside getack'
  1614. c    write(8,*) ' inside getack'
  1615. c  empty typeahead in case garbage
  1616. c    charintime=ttyinlim(sector,130,0)
  1617. c  allow time for disk file write at other end.  Typically 128 sectors.
  1618. c                        Sometimes only 1 track.
  1619.     charintime=ttyinlim(c,1,acklim)
  1620. c    print*,' getack got',c
  1621. c    write(8,*) ' getack got',c
  1622.     if( .NOT.charintime .OR. c.NE.ACK ) then
  1623. c        print *, ' not ACK, decimal=',c
  1624.         write(8,*) ' not ACK, decimal=',c
  1625.         errorcount=errorcount+1
  1626.         if(errorcount.GE.errlim) then
  1627.             write(8,*) ' not acknowleged in 10 tries.'
  1628. c            print *,' Can''t send sector. Aborting.'
  1629.             call cancel
  1630.         endif
  1631.         acked=.FALSE.
  1632.     else
  1633. c  received ACK
  1634.         acked=.TRUE.
  1635.     endif
  1636.     return
  1637.     end
  1638.